home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / hangman / clogo.cls < prev    next >
Encoding:
Visual Basic class definition  |  1999-09-06  |  6.4 KB  |  203 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "cLogo"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11.  
  12. Private Type RECT
  13.     left As Long
  14.     tOp As Long
  15.     Right As Long
  16.     Bottom As Long
  17. End Type
  18. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  19. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  20. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  21. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  22. Private Const LOGPIXELSX = 88    '  Logical pixels/inch in X
  23. Private Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
  24. Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  25. Private Const LF_FACESIZE = 32
  26. Private Type LOGFONT
  27.     lfHeight As Long
  28.     lfWidth As Long
  29.     lfEscapement As Long
  30.     lfOrientation As Long
  31.     lfWeight As Long
  32.     lfItalic As Byte
  33.     lfUnderline As Byte
  34.     lfStrikeOut As Byte
  35.     lfCharSet As Byte
  36.     lfOutPrecision As Byte
  37.     lfClipPrecision As Byte
  38.     lfQuality As Byte
  39.     lfPitchAndFamily As Byte
  40.     lfFaceName(LF_FACESIZE) As Byte
  41. End Type
  42. Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
  43. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  44. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  45. Private Const FW_NORMAL = 400
  46. Private Const FW_BOLD = 700
  47. Private Const FF_DONTCARE = 0
  48. Private Const DEFAULT_QUALITY = 0
  49. Private Const DEFAULT_PITCH = 0
  50. Private Const DEFAULT_CHARSET = 1
  51. Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
  52. Private Const CLR_INVALID = -1
  53.  
  54. Private m_picThis As PictureBox
  55. Private m_sCaption As String
  56. Private m_bRGBStart(1 To 3) As Integer
  57. Private m_oStartColor As OLE_COLOR
  58. Private m_bRGBEnd(1 To 3) As Integer
  59. Private m_oEndColor As OLE_COLOR
  60.  
  61. Public Property Let Caption(ByVal sCaption As String)
  62.     m_sCaption = sCaption
  63. End Property
  64.  
  65. Public Property Get Caption() As String
  66.     Caption = m_sCaption
  67. End Property
  68.  
  69. Public Property Let DrawingObject(ByRef picThis As PictureBox)
  70.     Set m_picThis = picThis
  71. End Property
  72.  
  73. Public Property Get StartColor() As OLE_COLOR
  74.     StartColor = m_oStartColor
  75. End Property
  76.  
  77. Public Property Let StartColor(ByVal oColor As OLE_COLOR)
  78. Dim lColor As Long
  79.     If (m_oStartColor <> oColor) Then
  80.         m_oStartColor = oColor
  81.         OleTranslateColor oColor, 0, lColor
  82.         m_bRGBStart(1) = lColor And &HFF&
  83.         m_bRGBStart(2) = ((lColor And &HFF00&) \ &H100)
  84.         m_bRGBStart(3) = ((lColor And &HFF0000) \ &H10000)
  85.         If Not (m_picThis Is Nothing) Then
  86.             Draw
  87.         End If
  88.     End If
  89.     
  90. End Property
  91.  
  92. Public Property Get EndColor() As OLE_COLOR
  93.     EndColor = m_oEndColor
  94. End Property
  95.  
  96. Public Property Let EndColor(ByVal oColor As OLE_COLOR)
  97. Dim lColor As Long
  98.     If (m_oEndColor <> oColor) Then
  99.         m_oEndColor = oColor
  100.         OleTranslateColor oColor, 0, lColor
  101.         m_bRGBEnd(1) = lColor And &HFF&
  102.         m_bRGBEnd(2) = ((lColor And &HFF00&) \ &H100)
  103.         m_bRGBEnd(3) = ((lColor And &HFF0000) \ &H10000)
  104.         If Not (m_picThis Is Nothing) Then
  105.             Draw
  106.         End If
  107.     End If
  108. End Property
  109.  
  110. Public Sub Draw()
  111. Dim lHeight As Long, lWidth As Long
  112. Dim lYStep As Long
  113. Dim lY As Long
  114. Dim bRGB(1 To 3) As Integer
  115. Dim tLF As LOGFONT
  116. Dim hFnt As Long
  117. Dim hFntOld As Long
  118. Dim lR As Long
  119. Dim rct As RECT
  120. Dim hBr As Long
  121. Dim hDC As Long
  122. Dim dR(1 To 3) As Double
  123. On Error GoTo DrawError
  124.  
  125.     hDC = m_picThis.hDC
  126.     lHeight = m_picThis.Height \ Screen.TwipsPerPixelY
  127.     rct.Right = m_picThis.Width \ Screen.TwipsPerPixelY
  128.     ' Set a graduation of 255 pixels:
  129.     lYStep = lHeight \ 255
  130.     If (lYStep = 0) Then
  131.         lYStep = 1
  132.     End If
  133.     rct.Bottom = lHeight
  134.     
  135.     bRGB(1) = m_bRGBStart(1)
  136.     bRGB(2) = m_bRGBStart(2)
  137.     bRGB(3) = m_bRGBStart(3)
  138.     dR(1) = m_bRGBEnd(1) - m_bRGBStart(1)
  139.     dR(2) = m_bRGBEnd(2) - m_bRGBStart(2)
  140.     dR(3) = m_bRGBEnd(3) - m_bRGBStart(3)
  141.         
  142.     For lY = lHeight To 0 Step -lYStep
  143.         ' Draw bar:
  144.         rct.tOp = rct.Bottom - lYStep
  145.         hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
  146.         FillRect hDC, rct, hBr
  147.         DeleteObject hBr
  148.         rct.Bottom = rct.tOp
  149.         ' Adjust colour:
  150.         bRGB(1) = m_bRGBStart(1) + dR(1) * (lHeight - lY) / lHeight
  151.         bRGB(2) = m_bRGBStart(2) + dR(2) * (lHeight - lY) / lHeight
  152.         bRGB(3) = m_bRGBStart(3) + dR(3) * (lHeight - lY) / lHeight
  153.         'Debug.Print bRGB(1), (lHeight - lY) / lHeight
  154.     Next lY
  155.     
  156.     pOLEFontToLogFont m_picThis.Font, hDC, tLF
  157.     tLF.lfEscapement = 900
  158.     hFnt = CreateFontIndirect(tLF)
  159.     If (hFnt <> 0) Then
  160.         hFntOld = SelectObject(hDC, hFnt)
  161.         lR = TextOut(hDC, 0, lHeight - 16, m_sCaption, Len(m_sCaption))
  162.         SelectObject hDC, hFntOld
  163.         DeleteObject hFnt
  164.     End If
  165.     
  166.     m_picThis.Refresh
  167.     Exit Sub
  168. DrawError:
  169.     Debug.Print "Problem: " & Err.Description
  170. End Sub
  171.  
  172. Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT)
  173. Dim sFont As String
  174. Dim iChar As Integer
  175.  
  176.     ' Convert an OLE StdFont to a LOGFONT structure:
  177.     With tLF
  178.         sFont = fntThis.Name
  179.         ' There is a quicker way involving StrConv and CopyMemory, but
  180.         ' this is simpler!:
  181.         For iChar = 1 To Len(sFont)
  182.             .lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1)))
  183.         Next iChar
  184.         ' Based on the Win32SDK documentation:
  185.         .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
  186.         .lfItalic = fntThis.Italic
  187.         If (fntThis.Bold) Then
  188.             .lfWeight = FW_BOLD
  189.         Else
  190.             .lfWeight = FW_NORMAL
  191.         End If
  192.         .lfUnderline = fntThis.Underline
  193.         .lfStrikeOut = fntThis.Strikethrough
  194.         
  195.     End With
  196.  
  197. End Sub
  198.  
  199. Private Sub Class_Initialize()
  200.     StartColor = &H0
  201.     EndColor = vbButtonFace
  202. End Sub
  203.